perm filename PLTCMX.F4[MSS,LCS]1 blob sn#077144 filedate 1974-03-19 generic text, type T, neo UTF8
00100	C**** PLTCMD, FILLER, NNN, UNPACK, ROFF ********
38800		SUBROUTINE PLTCMD
38900	CC	IMPLICIT INTEGER(A-Q,S-Z)
39000		COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
39100		DIMENSION NMS(8),RMOV1(8),RMOV2(8)
39200		COMMON /DL/X22,SAVER,NAME /ALF/INP(3),ML
39400		COMMON RJB,JE,CENTR,JB,RJQ(20),JQ(20)
39700		EQUIVALENCE (RJE,RJQ(3)),(RJF,RJQ(4)),(RJG,RJQ(5)),(RJD,RJQ(2))
39800		1,(RJC,RJQ(1)),(I2,INP(2)),(RJH,RJQ(6)),(I3,INP(3))
39950		F78F(1)='(78F)'
39960		FA5(1)='(A5) '
39970		FA1(1)='(A1) '
40000	
40100		IF(I2.NE.'X')GO TO 1
40150	CC	ML=' '
40200		I2=0
40300		RXC=0
40400		RMOV1(1)='Y'
40500		NAME=0
40600	14	KA=0
40700	3	KA=KA+1
40710	CC	IF(ML.EQ.' ')GO TO 15
40715		IF(ML.EQ.0)GO TO 15
40720		K=K-2
40725		ML=ML-1
40730		IF(ML.EQ.0)GO TO 10
40740		GO TO 31
40800	15	TYPE 2,KA
40900		ACCEPT 11,K,ML
40950	C  TYPE LAST NAME, NUMBER  FOR A SERIES
41000	50	IF(K.EQ.' ')GO TO 10
41100		IF(K.EQ.'99')GO TO 140
41200	C  99=BACKUP
41300	31	IF(LOOKD(K))GO TO 56
41400	C JUMP IF FILE FOUND
41500		TYPE 55
41600		GO TO 15
41700	55	FORMAT(' FILE NOT FOUND'/)
41750	11	FORMAT(A5,I)
41800	56	NMS(KA)=K
41810	CC	IF(ML.EQ.' ')GO TO 5
41820		IF(ML.EQ.0)GO TO 5
41855		RJH='Y'
41877		GO TO 21
41900	5	TYPE 8
42000		ACCEPT FA5,RJH
42100		IF(RJH.EQ.'99')GO TO 15
42200		IF(RJH.NE.'Y')RJH=0
42300		IF(RJH.EQ.0)REREAD F78F,RJH
42400	C  MOVE NUMBER CAN BE TYPED FOR 'MOVE UP'
42500	21	RMOV1(KA+1)=RJH
42600		RMOV2(KA)=RJH
42700		GO TO 3
42800	140	KA=KA-1
42900		GO TO 15
43000	
43100	10	KB=KA-1
43110		IF(I3.NE.'G')GO TO 22
43120		RSIZ=1
43130		GO TO 222
43200	22	TYPE 9
43300		ACCEPT F78F,RSIZ
43400		IF(RSIZ.EQ.99.OR.RSIZ.EQ.0)GO TO 5
43500	222	KA=0
43600	
43700	1	IF(NAME.NE.0)GO TO 12
43800		IF(KA.EQ.KB)CALL PLOT(0,0,99)
43900		NAME=NMS(KA+1)
44000		TYPE 111,NAME
44100		RETURN
44200	12	KA=KA+1
44300		NAME=0
44400		RJD=1
44500		IF(INP(3).EQ.'C')RJD=0
44600	C  'PXC' = CALCOMP OUTPUT
44700		RJH=0
44800		RJB=RSIZ
44900		RJC=RSIZ
45000		RJG=0
45100		RJE=1
45200		RJF=1
45300		IF(RMOV2(KA).NE.'Y')RJG=RMOV2(KA)
45400		IF(RMOV1(KA).NE.0)RJE=0
45500		IF(RMOV2(KA).NE.0.OR.RJG.NE.0)RJF=0
45600	2	FORMAT(' TYPE FILE NAME',I2,1X$)
45700	8	FORMAT(' MOVE UP AT END? ',$)
45800	9	FORMAT(' SIZE FACTOR? ',$)
45900	111	FORMAT(1XA5/)
46000		END
47000		SUBROUTINE FILLER(IFILL,QJB,QCENT,BX,BY)
47100		DIMENSION IFILL(1)
47200		COMMON /DL/IXRX,SAVER,NAME
47300		COMMON /SIZ/RSZ,JCEN,KCEN
47400		COMMON /FL/IC,N,NQ,RZ,XGP
47500		COMMON /STF/RSTFAC(8),RSTJC
47600		COMMON /PLTR/IPLT,RHT,DIS
47700		COMMON/DPY/IGO,RXGP,ITOP,IBOT
48000		PX=1
48100		IF(BX.EQ.0)BX=1
48200		IF(BY.EQ.0)BY=1
48300		IF(BX)PX=-1
48400		IXGP=XGP
48500		RSI=RSTJC*BY
48600	C  RI IS INVERSION FACTOR
48700		BZ=BY/BX
48800		RT=RSTJC*BX
48900	C  RS=HORIZ.    RT=VERT.
49000		JXGP=RXGP
49100		NX=2
49200	C  NX IS POINTER IN X ARRAY
49300		ID=IFILL(NX)
49400		IF(IPLT)GO TO 101
49500		RBZ=QJB*RSZ
49600		RXX=RSZ*RT
49700	C  WHAT ABOUT RXX???????? 
49800		RYX=QCENT*RSZ
49900		RXY=RSI*RSZ
50000		GO TO 100
50100	101	RXX=RT*DIS
50200		RXY=RSI*RHT
50300		RBZ=QJB*DIS
50400		RYX=QCENT*RHT
50500	100	RM=-1000
50600		IF(PX)RM=-RM
50700		I=NX+1
50800	103	CALL UNPACK(IA,IB,IFILL(I))
50900		IF(IA.NE.IFILL(I+1)/10000)GO TO 102
51000		I=I+1
51100		GO TO 103
51200	102	G=IA*RT+QJB
51300		H=IB*RSI+QCENT
51400		IF(IPLT)GO TO 200
51500		CALL LINES(G,H,3)
51600		GO TO 300
51700	200	IF(IXRX.EQ.0)GO TO 90
51800		M=ROFF(-H*RHT+RXGP)
51900		N=ROFF(G*DIS+XGP)
52000		GO TO 80
52100	90	M=ROFF(G*DIS)
52200		N=ROFF(H*RHT)
52300	80	CALL PLOT(M,N,3)
52400	300	NN=ID-1
52500	C  LAST OF ARRAY-1
52600		P=IA*RXX
52700		CALL UNPACK(IG,H,IFILL(I+1))
52800		RB=IG*RXX+PX
52900		J=1
53000	1	JJ=1
53100		IF(PX)GO TO 30
53200		IF(RM.GT.RB)GO TO 13
53300		GO TO 31
53400	30	IF(RM.LT.RB)GO TO 13
53500	31	IF(J)GO TO 2
53600	3	CALL NNN(NN,1,0,IFILL)
53700	C  FINDS BOTTOM POINTER
53800		GO TO 16	
53900	2	CALL NNN(I,0,1,IFILL)
54000	C  FINDS TOP POINTER(I)
54100	16	CALL UNPACK(JAX,JB,IFILL(N))
54200		CALL UNPACK(JG,JH,IFILL(N+1))
54300		CALL UNPACK(IQ,H,IFILL(NQ))
54400		RZ=RZ*RXX
54500	10	RDIS=JAX-JG
54600		IF(PX)GO TO 32
54700		IF(P.GT.RZ)P=RZ
54800		GO TO 33
54900	32	IF(P.LT.RZ)P=RZ
55000	C  REVERSES VERT.
55100	33	Q=IQ*RXX
55200		C=IC*RXY+RYX
55300		IF(RDIS.NE.0)GO TO 6
55400	C  FOR STRAIIGHT UP-DOWN LINES
55500		IF(NN-1.EQ.I)GO TO 13
55600		P=P-PX
55700		GO TO 5
55800	6	H=BZ*(JB-JH)/RDIS
55900	11	HH=(P-Q)*H+C
56000		PP=P+RBZ
56100		IH=ROFF(HH)
56200		IP=ROFF(PP)
56300	C  ROFF IS FOR ROUND-OFF ERRORS
56400		IF(IP.EQ.MP.AND.IH.EQ.MH)GO TO 180
56500		MP=IP
56600		MH=IH
56700	C  OMITS REPEATED POINTS
56800		IF(IPLT)GO TO 17
56900	CC	IF(RSZ.LE.0.8571)GO TO 34
57000	CC	IP=IP-JCEN
57100	CC	IH=IH-KCEN
57200	CC34	CALL AVECT(IP,IH)
57300		CALL LINES(PP/RSZ,HH/RSZ,2)
57400		GO TO 180
57500	17	IF(IXRX.EQ.0)GO TO 19
57600		K=IP
57700		IP=-IH+JXGP
57800	C NO RNDOFF OR DIS-RHT FACTORS HERE YET.
57900		IH=K+IXGP
58000	19	CALL PLOT(IP,IH,2)
58100	180	JJ=JJ-1
58200		IF(JJ)GO TO 12
58300		RM=P
58400		P=P+PX
58500		IF(PX)GO TO 35
58600		IF(P.LT.RZ)GO TO 11
58700		GO TO 5
58800	35	IF(P.GT.RZ)GO TO 11
58900	5	IF(J)GO TO 4
59000		NN=NN-1
59100		IF(I.GT.NN)GO TO 13
59200		GO TO 3
59300	4	I=I+1
59400		IF(I.GT.NN)GO TO 13
59500	402	CALL UNPACK(IA,IB,IFILL(I+1))
59600		RB=IA*RXX+PX
59700		GO TO 2
59800	12	J=-J
59900		GO TO 1
60000	13	NX=ID+1
60100		IF(ID.EQ.IFILL(1))GO TO 130
60200		ID=IFILL(NX)
60300		GO TO 100
60400	130	MP=1000
60500		MH=1000
60600		RETURN
60700		END
60800	
60900		SUBROUTINE NNN(J,L,K,IFILL)
61000		COMMON /FL/IC,N,NQ,RZ,XGP
61100		DIMENSION IFILL(1)
61200		CALL UNPACK(IZ,IC,IFILL(J+K))
61300		CALL UNPACK(N,IC,IFILL(J+L))
61400		N=J
61500	C  C IS THE CONSTANT
61600		NQ=N+L
61700		RZ=IZ
61800		RETURN
61900		END
62000	
62100		SUBROUTINE UNPACK(M,N,I)
62200		COMMON/LL/L
62300	C  L IS FOR VIS. OR INVIS. LINES.
62400		N=I
62500		L=2
62600		IF(N.LT.100000000)GO TO 2
62700		L=3
62800		N=N-100000000
62900	2	M=N/10000
63000		N=N-M*10000
63100		IF(M.GT.1000)M=1000-M
63200		IF(N.GT.1000)N=1000-N
63300		RETURN
63400		END
63500	
63600		FUNCTION ROFF(R)
63700		S=.5
63800		IF(R)S=-S
63900		ROFF=R+S
64000		RETURN
64100		END